home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / VGA_VUL5.ZIP / STARS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1995-10-20  |  4.2 KB  |  156 lines
  1. { === Example of a 3d-starfield in Pascal. By Vulture / Outlaw Triad === }
  2.  
  3. Program StarField3D;
  4.  
  5. Uses Crt;
  6.  
  7. Type StarFormat = Record                 { Format of star }
  8.                     X, Y, Z: Integer;    { 3d = x,y,z }
  9.                     OX, OY: Integer;     { 2d = x,y (here for deletion) }
  10.                     Color: Byte;
  11.                   End;
  12.  
  13. Const VGA = $A000;        { VGA-segment }
  14.       MaxStars = 350;     { Guess what? ;-) }
  15.       Xoff = 160;         { Used for calculating vga-pos }
  16.       Yoff = 100;
  17.       Zoff = 255;         { Stars are way deep in space }
  18.       WarpSpeed = 1;      { Speed of stars }
  19.  
  20. Var Stars: Array[1..MaxStars] of StarFormat;  { Array to hold all data }
  21.     Loop1: Integer;       { Used in 2 routines }
  22.  
  23. Procedure VideoMode(Mode: Byte); Assembler;
  24. Asm
  25.   mov  ah,00
  26.   mov  al,Mode
  27.   int  10h
  28. End;
  29.  
  30. Procedure SetPixel(X,Y:Integer;Color:Byte;Where:Word); Assembler;
  31. Asm                         { TP automatically pushes and pops ES }
  32.   mov  ax,[Where]           { Move destination in AX }
  33.   mov  es,ax                { es => points to VGA or virtual screen }
  34.   mov  di,Y                 { Move Y into DI }
  35.   mov  ax,Y                 { Move Y into AX }
  36.   shl  di,8                 { DI := DI * 256 }
  37.   shl  ax,6                 { AX := AX * 64 }
  38.   add  di,ax                { DI := Y * 320 }
  39.   mov  ax,X                 { Move X into AX }
  40.   add  di,ax                { DI = X + Y   final location }
  41.   mov  al,Color             { Set color }
  42.   mov  byte ptr es:[di],al  { Place the dot }
  43. End;
  44.  
  45. Procedure SetColor(Color,R,G,B: Byte);
  46. Begin
  47.    asm
  48.      mov    dx,3C8h
  49.      mov    al,[Color]
  50.      out    dx,al
  51.      inc    dx
  52.      mov    al,[R]
  53.      out    dx,al
  54.      mov    al,[G]
  55.      out    dx,al
  56.      mov    al,[B]
  57.      out    dx,al
  58.   end;
  59. End;
  60.  
  61. Procedure WaitRetrace; Assembler;  { Waits for Vertical Retrace }
  62. label l1, l2;
  63. Asm
  64.    mov  dx,3DAh
  65. l1:
  66.    in   al,dx
  67.    and  al,08h
  68.    jnz  l1
  69. l2:
  70.    in   al,dx
  71.    and  al,08h
  72.    jz   l2
  73. End;
  74.  
  75. Procedure EditPalette;          { Change palette for starfield }
  76. Var Number, C: Integer;
  77. Begin
  78.   C := 10;
  79.   For Number := 1 to 5 Do
  80.   Begin
  81.     SetColor(Number,C,C,C);
  82.     INC(C,10);
  83.   End;
  84. End;
  85.  
  86. Procedure InitializeStars;         { Init all stars here }
  87. Var Loop1: Integer;
  88. Begin
  89.   For Loop1 := 1 to MaxStars Do
  90.   Begin
  91.     Stars[loop1].X:=Random(320)-160;
  92.     Stars[loop1].Y:=Random(200)-100;
  93.     Stars[loop1].Z:=Random(255);
  94.   End;
  95. End;
  96.  
  97. Procedure CreateStar(A: Integer);  { If star was aborted, create a new one }
  98. Begin
  99.   Stars[A].X := Random(320)-160;
  100.   Stars[A].Y := Random(200)-100;
  101.   Stars[A].Z := Zoff;
  102. End;
  103.  
  104. Procedure Color(A: Integer);       { Get color for star (ugly code!) }
  105. Begin
  106.   Case A Of
  107.     1..50    : Stars[Loop1].Color := 5;
  108.     51..100  : Stars[Loop1].Color := 4;
  109.     101..150 : Stars[Loop1].Color := 3;
  110.     151..200 : Stars[Loop1].Color := 2;
  111.     201..255 : Stars[Loop1].Color := 1;
  112.   End;
  113. End;
  114.  
  115. Procedure CalcStars;
  116. Var NX,NY: Integer;
  117. Begin
  118.   For Loop1 := 1 to MaxStars Do
  119.   Begin
  120.     If Stars[Loop1].Z > 0 then
  121.     Begin
  122.       NX := ((Stars[Loop1].X shl 7) div Stars[Loop1].Z) + Xoff;
  123.       NY := ((Stars[Loop1].Y shl 7) div Stars[Loop1].Z) + Yoff;
  124.       If (NX > 0) AND (NX < 320) AND (NY > 0) AND (NY < 200) Then
  125.       Begin
  126.         Color(Stars[Loop1].Z);
  127.         SetPixel(NX, NY, Stars[Loop1].Color, VGA);
  128.         Stars[Loop1].OX := NX;
  129.         Stars[Loop1].OY := NY;
  130.         Dec(Stars[Loop1].Z,WarpSpeed);  { Go towards viewer }
  131.       End
  132.       Else CreateStar(Loop1);    { Not in VGA-range ... create new star }
  133.     End
  134.     Else CreateStar(Loop1);      { Reached Z = 0 ... create new star }
  135.   End;
  136. End;
  137.  
  138. Procedure DeleteStars;           { Delete all stars at once }
  139. Var Loop1: Integer;
  140. Begin
  141.   For Loop1 := 1 to MaxStars Do SetPixel(Stars[Loop1].OX, Stars[Loop1].OY, 0, VGA);
  142. End;
  143.  
  144. Begin
  145.   RandoMize;            { Truly random }
  146.   VideoMode($13);
  147.   InitializeStars;
  148.   EditPalette;
  149.   Repeat
  150.     CalcStars;          { Improve and show new stars }
  151.     WaitRetrace;
  152.     DeleteStars;        { Delete them stars }
  153.   Until KeyPressed;
  154.   VideoMode($3);
  155.   Writeln('Code by Vulture / Outlaw Triad');       { Who's done it ? }
  156. End.